home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / dviware / crudetype / version3 / nosvebind.cyb < prev    next >
Text File  |  1991-11-28  |  49KB  |  1,451 lines
  1. Here you find Norbert Schwarz's cybil routines for dynamic file 
  2. binding in Pascal which he devoloped for his NOS/VE TeX 
  3. implementation. There are four files combined into this file:
  4. ASSOCIATE_FILE_CYBIL and UTM_OPEN2_CYBIL are the Cybil sources,
  5. BINCOR_PAS is a program to do a binary correction to the compiled
  6. output and MAKE_UTM_OPEN2_LIB the installation procedure (study it
  7. to find out what's going on). The binary correction is likely to
  8. change at new system releases.
  9.  
  10. THe software is by
  11.  
  12. Norbert Schwarz
  13. Ruhr-Universitaet Bochum, Rechenzentrum
  14. Postfach 102148
  15. D-4630 Bochum 1
  16. P920012 at DBORUB01.BITNET
  17.  
  18. %%%%%%%%%%%%%%%%% MAKE_UTM_OPEN2_LIB %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  19.  
  20. proc make_utm_open2_lib (ergebnis : file = $required               ;
  21.                        debug    : name = all  );
  22. create_variable ss kind=status;
  23.  
  24. copy_file $user.tex122.utm_open2_exp_cybil $local.compile
  25. DELETE_FILE $local.UTM_OPEN  status=ss
  26. CYBIL $local.COMPILE DA=$value(debug) B=$local.UTM_OPEN  l=$local.cybil_liste
  27. " ---> correct the debug match information (loader problem)
  28. "    06c7... is the old declaration matching value
  29. "    To get the required new one, use DISPLAY_OBJECT_TEXT
  30.  
  31. "    for the module PAM$$FILE_TABLE_ROUTINE in $SYSTEM.PASCAL.PAF$LIBRARY
  32. collect_text $local.DATEN
  33. UTM_OPEN
  34. 06C764D1A410E3EB*
  35. 0AAD64BCC195277B*
  36. **
  37. old_catalog=$string($catalog)
  38. set_working_catalog $local
  39. .zztv.tex122.bincor $local.DATEN
  40. set_working_catalog $fname(old_catalog)
  41. create_object_library
  42.   add_module $local.utm_open
  43.   generate_library $value(ergebnis)
  44.   quit
  45. put_line ' utm_open_lib erstellt in'//$string($value(ergebnis))
  46. PROCEND;
  47.  
  48. %%%%%%%%%%%%%%%%% BINCOR_PAS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  49. program bincor (input, output);
  50.  
  51. type    byte = 0..255;
  52.         t_p = packed array[1..100000] of byte;
  53.         t_packed = ^t_p;
  54.         twochar = packed array[1..2] of char;
  55.         string31 = packed array[1..31] of char;
  56.         string_type = packed array[1..17] of char;
  57.         word_type = array[1..8] of 0..255;
  58.  
  59. var     infile,outfile : t_packed;
  60.         status : integer;
  61.  
  62.         i,j,position : integer;
  63.  
  64.         corr_file_name : string31;
  65.         old_wordstring : string_type;
  66.         new_wordstring : string_type;
  67.  
  68.         old_word : word_type;
  69.         new_word : word_type;
  70.  
  71.         old_lng  : integer;
  72.         new_lng  :integer;
  73.  
  74. procedure get_string(var instring : string_type);
  75. var i: integer;
  76.     c:char;
  77. begin
  78.      for i:=1 to 17 do instring[i] := '*';
  79.      i:=0;
  80.      repeat
  81.        if eoln(input) then readln(input);
  82.        read(c);
  83.        if (c<>'*') and (c<>' ') then begin i:=i+1; instring[i]:=c; end;
  84.      until (i=17) or (c='*');
  85. end;
  86.  
  87. function tobin(c2 : twochar) : integer;
  88. var  c: char; i1,i2 : integer;
  89. begin
  90.    c :=c2[1];
  91.    if (c>='A') then i1:=10+ord(c)-ord('A') else i1:= ord(c)-ord('0');
  92.    c :=c2[2];
  93.    if (c>='A') then i2:=10+ord(c)-ord('A') else i2:= ord(c)-ord('0');
  94.    tobin := i1*16 + i2;
  95. end;
  96.  
  97.  
  98. procedure string_value (instring : string_type; var count : integer;
  99.                                                 var bytes : word_type);
  100. var i,k : integer; c: char;
  101.     c2 : twochar;
  102. begin
  103.   count:=0;
  104.   i:=1;
  105.   while (i<=17) and (instring[i]<>'*') do
  106.   begin
  107.      c2[1] := instring[i];
  108.      c2[2] := instring[i+1];
  109.      i:=i+2;
  110.      count:=count+1;
  111.      bytes[count] := tobin(c2);
  112.   end;
  113. end;
  114.  
  115. procedure tohex(i:byte; var erg : twochar);
  116. var hilf : byte;
  117. begin
  118.    hilf := i div 16;
  119.    if hilf>9 then  erg[1] := chr(ord('A')+hilf-10)
  120.              else  erg[1] := chr(ord('0')+hilf);
  121.    hilf:= i mod 16;
  122.    if hilf>9 then  erg[2] := chr(ord('A')+hilf-10)
  123.              else  erg[2] := chr(ord('0')+hilf);
  124. end;
  125.  
  126.  
  127. procedure search_string(f : t_packed; to_search : word_type; lng : integer;
  128.                         var found : integer);
  129. const max_search =20000;
  130. var i,k,l : integer;
  131.     gefunden : boolean;
  132. begin
  133.     i:=0;
  134.     found := -1;
  135.     while (i<max_search)  do
  136.     begin
  137.       i:=i+1;
  138.       gefunden := true;
  139.       j:=0;
  140.       while (gefunden) and (j<lng) do
  141.         begin   if f^[i+j]<> to_search[j+1] then gefunden := false;
  142.                 j:=j+1;
  143.         end;
  144.      if gefunden then begin
  145.          found := i;
  146.          i:= max_search+1;
  147.      end;
  148.     end;
  149. end;
  150.  
  151. procedure dump(f : t_packed);
  152. var  b :byte;
  153.      c2 : twochar;
  154.      column :  integer;
  155.      i:integer;
  156. begin
  157.    column :=0;
  158.    write('    ');
  159.    for i:=1 to 300  do
  160.    begin
  161.       tohex(f^[i],c2);
  162.       write(output,c2);
  163.       column :=column + 2;
  164.       if column=40 then begin column:= 0; writeln(output); write(' ') end;
  165.    end;
  166. end;
  167.  
  168. procedure associate_file(f:string31;var ff : t_packed; var ii :integer);
  169. external;
  170.  
  171. begin
  172.    for i:=1 to 31 do corr_file_name[i] := ' ';
  173.    write(' FILE to be changed: ');
  174.    i:=1;
  175. while (not eoln(input)) and (i<32) do begin read(corr_file_name[i]); i:=i+1 end;
  176.    readln;
  177.    status:=0;
  178.    associate_file(corr_file_name,infile,status);
  179.    writeln(' Assoziation - status ',status);
  180.    dump(infile);
  181.    get_string(old_wordstring); get_string(new_wordstring);
  182.  
  183.  
  184.  
  185.    string_value(old_wordstring,old_lng,old_word);
  186.    string_value(new_wordstring,new_lng,new_word);
  187.  
  188.    write(' to replace >');
  189.    for i:=1 to 2*old_lng do write(old_wordstring[i]);
  190.    write(' (',old_lng:1,') ');
  191.    write('< by the new >');
  192.    write(' (',new_lng:1,')');
  193.    for i:=1 to 2*new_lng do write(new_wordstring[i]);
  194.    writeln('<');
  195.  
  196.  
  197.    search_string(infile, old_word,old_lng,position);
  198.    writeln(' Position ',position);
  199.    if position > 0 then
  200.       begin
  201.         for i:=1 to new_lng do
  202.             infile^[position-1+i] := new_word[i];
  203.       end;
  204. end .
  205.  
  206. %%%%%%%%%%%%%%%%% ASSOCIATE_FILE_CYBIL %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  207. module nsm_associate_file;
  208.  
  209. *copyc AMP$OPEN
  210. *copyc AMP$GET_SEGMENT_POINTER
  211.  
  212. procedure [XDCL] associate_file  (file_name : ost$name;
  213.                                    var file_pointer : ^cell;
  214.                                    var status : integer);
  215.  
  216. var  local_file_name  : ost$name;
  217. var  file_id          : amt$file_identifier;
  218. var  status1,status2  : ost$status;
  219. var  segment_pointer  : amt$segment_pointer;
  220.  
  221.     local_file_name := file_name;
  222.  
  223.     amp$open ( local_file_name, amc$segment, NIL, file_id,status1);
  224.  
  225.     if status1.normal then
  226.  
  227.          amp$get_segment_pointer ( file_id,
  228.                                    amc$cell_pointer,
  229.                                     segment_pointer,
  230.                                    status2);
  231.  
  232.          file_pointer := segment_pointer.cell_pointer;
  233.          if status2.normal then status := 0 else
  234.                 status :=  status2.condition;
  235.          ifend;
  236.     else
  237.         status :=   status1.condition;
  238.     ifend;
  239.  
  240. procend ;
  241.  
  242. *copyc AMP$GET_FILE_ATTRIBUTES
  243.  
  244. procedure [XDCL] get_file_length (file_name : ost$name;
  245.                                   var length : integer );
  246.  
  247. var   attributes : ^amt$get_attributes;
  248. var   local      : boolean;
  249. var   old_file   : boolean;
  250. var   non_empty  : boolean;
  251. var   status     : ost$status;
  252.  
  253.  
  254.  PUSH  attributes : [1..1];
  255.  
  256.  attributes^[1].key := amc$file_length;
  257.  
  258.  amp$get_file_attributes(file_name,attributes^,local,old_file,
  259.                          non_empty,status);
  260.  
  261.   if status.normal then
  262.      length := attributes^[1].file_length;
  263.   else
  264.      length := -1;
  265.   ifend;
  266.  
  267. procend get_file_length;
  268. modend;
  269. %%%%%%%%%%%%%%%%% UTM_OPEN2_CYBIL %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  270. module utm_open_module;
  271.  
  272. { This routines looks into the file-table-area of the PASCAL-runtime system
  273. { an searches an entry with an matching "file-variable"-pointer.
  274. { It is found the file-name will be replaced by the given one of
  275. { the proceure call }
  276.  
  277. { Very very important:  As the parameter definition is not known
  278. {                       of the corresponding CYBIL-routines of
  279. {                       PAF$LIBRARY there has a binary correction
  280. {                       of the matching value for the entry
  281. {                       PAV$FILE_TABLE_PTR to be done !!!}
  282.  
  283. { -------- last change 21.11.1986   Ruhr Universitaet Bochum, Germany
  284. {                                  Norbert Schwarz                         }
  285.  
  286. { change 12.06.86       included the function                              }
  287. {                                                                          }
  288. {                       if a "file-name" begins with a '<' character       }
  289. {                       then the part between '<' and '>' will be inter-   }
  290. {                       preted as a SCL string-name, which contains        }
  291. {                       the catalog/file name                              }
  292. {                       the SCL-string may be an array of strings then     }
  293. {                       a hierarchical search will be done.                }
  294. {                                                                          }
  295. { 16.06.1986            splitting of various open functions in             }
  296. {                       'open,openread,openwrite,openintern'               }
  297.  
  298. { 20.01.1987            introduction of opensegmented / closesegmented     }
  299.  
  300. { 12.03.1987            introduction of PUT_PARTIAL                        }
  301.  
  302. *copyc FSP$OPEN_FILE
  303. *copyc FSP$CLOSE_FILE
  304. *copyc AMP$get_segment_pointer
  305. *copyc AMP$SET_SEGMENT_EOI
  306. *copyc AMP$PUT_NEXT
  307. *copyc AMP$PUT_PARTIAL
  308. *copyc CLP$PUSH_PARAMETERS
  309. *copyc CLP$POP_PARAMETERS
  310. *copyc CLP$SCAN_PARAMETER_LIST
  311. *copyc CLP$GET_VALUE
  312. *copyc CLP$GET_PATH_DESCRIPTION
  313. *copyc CLP$CONVERT_INTEGER_TO_STRING
  314. *copyc AMP$CLOSE
  315. *copyc AMP$GET_FILE_ATTRIBUTES
  316. {*copyc IFP$STORE_TERMINAL }
  317. *copyc CLP$READ_VARIABLE
  318. *copyc PMP$ABORT
  319. *copyc PMP$EXIT
  320.  
  321. type  eightbit_range = 0..255;
  322.  
  323. type  two_word    =  array[1..2] of integer;
  324. type  two_word_id =  record
  325.                        case boolean of
  326.                        = true = int : two_word,
  327.                        =false = id  : amt$file_identifier,
  328.                        casend,
  329.                      recend;
  330.  
  331.  
  332.  
  333.  var    PAV$FILE_TABLE_PTR : [XREF,READ] ^cell;
  334.  
  335.  
  336.  
  337.  
  338.  procedure [XDCL] set_pascal_name
  339.  
  340.      ( VAR  file_variable :  cell;
  341.        file_name     : string(31)   );
  342.  
  343.  type  table_entry = packed record
  344.                      file_adress : ^cell,
  345.                      new_name    : string(31),
  346.                      old_name    : string(31),
  347.                      rest1       : string(6),
  348.                      buffer_ptr  : ^cell,
  349.                      rest2       : string(64),
  350.                      recend;
  351.  type   table_type = packed array[1..100] of table_entry;
  352.  
  353.  var     hilf_ptr : ^table_type;
  354.  var    i : integer;
  355.        hilf_ptr := PAV$FILE_TABLE_PTR;
  356.        for i:=1 to 100 do
  357.           if hilf_ptr^[i].file_adress=^file_variable then
  358.                 hilf_ptr^[i].new_name := file_name;
  359.              EXIT set_pascal_name;
  360.           ifend;
  361.        forend;
  362.  
  363.  PROCEND set_pascal_name;
  364.  
  365.  
  366. {  This routine looks into the file_table and searches an entry
  367. {  with an matching file name. Then it replaces the adress of
  368. {  the file-variable by the new given file-variable }
  369.  
  370.   procedure [XDCL] set_file_variable
  371.  
  372.      ( VAR  file_variable :  cell;
  373.        file_name     : string(31)   );
  374.  
  375.  type  table_entry = packed record
  376.                      file_adress : ^cell,
  377.                      new_name    : string(31),
  378.                      old_name    : string(31),
  379.                      rest1       : string(6),
  380.                      buffer_ptr  : ^cell,
  381.                      rest2       : string(64),
  382.                      recend;
  383.  type   table_type = packed array[1..100] of table_entry;
  384.  
  385.  var     hilf_ptr : ^table_type;
  386.  var    i : integer;
  387.        hilf_ptr := PAV$FILE_TABLE_PTR;
  388.        for i:=1 to 100 do
  389.           if hilf_ptr^[i].new_name = file_name then
  390.              hilf_ptr^[i].file_adress:=^file_variable ;
  391.              EXIT set_file_variable;
  392.           ifend;
  393.        forend;
  394.  
  395.  PROCEND set_file_variable;
  396.  
  397.  
  398. { This procedure inserts a new file_name and a new_pointer into }
  399. { the file-table !                                              }
  400.  
  401.  
  402.  procedure [XDCL] insert_file_variable
  403.  
  404.      ( VAR  file_variable :  cell;
  405.        file_name     : string(31) ;
  406.        textfile      : boolean      );
  407.  
  408. type   byte6       = packed array[1..6] of eightbit_range;
  409. type   byte64      = packed array[1..64] of eightbit_range;
  410.  
  411. type   file_ref    = packed record
  412.                        case boolean of
  413.                        = true  =     file_adress : ^cell,
  414.                        = false =     file_adress_bin : byte6,
  415.                       casend,
  416.                      recend;
  417.  
  418.  type  table_entry = packed record
  419.                      file_pt     : file_ref,
  420.                      new_name    : string(31),
  421.                      old_name    : string(31),
  422.                      rest1       : byte6,
  423.                      buffer_ptr  : ^cell,
  424.                      rest3       : byte64,
  425.                      recend;
  426.  type   table_type = packed array[1..100] of table_entry;
  427.  
  428.  var    hilf_ptr : ^table_type;
  429.  var    nil_test : ^cell;
  430.  var    i : integer;
  431.  var    k : integer;
  432.  var    file_adress_bin : integer;
  433.  
  434.        nil_test :=NIL;
  435.        hilf_ptr := PAV$FILE_TABLE_PTR;
  436.        FOR i:=1 to 100 DO
  437.           IF      hilf_ptr^[i].file_pt.file_adress_bin[1]=0
  438.           THEN
  439.              for k:=1 to 6  do hilf_ptr^[i].rest1[k] :=0; forend;
  440.              for k:=1 to 64 do hilf_ptr^[i].rest3[k] :=0; forend;
  441.              hilf_ptr^[i].file_pt.file_adress:=^file_variable ;
  442.              hilf_ptr^[i].old_name:=file_name ;
  443.              hilf_ptr^[i].new_name:=file_name;
  444.              hilf_ptr^[i].rest1[6] := 050(16);
  445.              hilf_ptr^[i].buffer_ptr := NIL;
  446.              hilf_ptr^[i].rest3[16] := 0;
  447.              IF textfile THEN
  448.                   hilf_ptr^[i].rest3[17] := 1;
  449.              ELSE
  450.                   hilf_ptr^[i].rest3[17] := 0;
  451.              IFEND;
  452.              hilf_ptr^[i].rest3[23] := 1;
  453.              hilf_ptr^[i].rest3[56] := 1;
  454.              EXIT insert_file_variable;
  455.           ELSE
  456.              IF hilf_ptr^[i].file_pt.file_adress = ^file_variable THEN
  457.                 for k:=1 to 6  do hilf_ptr^[i].rest1[k] :=0; forend;
  458.                 for k:=1 to 64 do hilf_ptr^[i].rest3[k] :=0; forend;
  459.                 hilf_ptr^[i].old_name:=file_name ;
  460.                 hilf_ptr^[i].new_name:=file_name;
  461.                 hilf_ptr^[i].rest1[6] := 050(16);
  462.                 hilf_ptr^[i].buffer_ptr := NIL;
  463.                 hilf_ptr^[i].rest3[16] := 0;
  464.                 hilf_ptr^[i].rest3[56] := 1;
  465.                 IF textfile THEN
  466.                   hilf_ptr^[i].rest3[17] := 1;
  467.                 ELSE
  468.                   hilf_ptr^[i].rest3[17] := 0;
  469.                 IFEND;
  470.                 hilf_ptr^[i].rest3[23] := 1;
  471.                 EXIT insert_file_variable;
  472.              IFEND
  473.           IFEND;
  474.        FOREND;
  475.  
  476.  PROCEND insert_file_variable;
  477.  
  478. { ======================================================================       }
  479. {                                                                              }
  480. { There are 4 'open' interfaces with different handling of existing files:     }
  481. {                                                                              }
  482. {   open,openread,openwrite,openintern                                         }
  483. {                                                                              }
  484. {    The parameter 'long_name_of_file' may contain a 'path-description'        }
  485. {    in '<' and '>' at the beginning of the name. The name betweeen < and >    }
  486. {    will be interpreted as a name of a SCL (!) - variable of kind string      }
  487. {    which contains a catalog reference                                        }
  488. {                                                                              }
  489. {    For example:   in SCL   CREATE_VARIABLE MY_BASE K=STRING D=1..4           }
  490. {                            MY_BASE(1)='$CATALOG'                             }
  491. {                            MY_BASE(2)='$LOCAL'                               }
  492. {                            MY_BASE(3)='$USER.BASE_CATALOG'                   }
  493. {                            MY_BASE(4)=':NVE.SMITH.FRIEND_CATALOG'            }
  494. {                                                                              }
  495. {    then a content of 'long_name_of_file' like                                }
  496. {                                                                              }
  497. {       '<MY_BASE>DATA'                                                        }
  498. {                                                                              }
  499. {     will be expanded to  (1.)  '$CATALOG.DATA'                               }
  500. {                          (2.)  '$LOCAL.DATA'                                 }
  501. {                          (3.)  '$USER.BASE_CATALOG.DATA'                     }
  502. {                          (4.)  ':NVE.SMITH.FRIEND_CATALOG.DATA'              }
  503. {                                                                              }
  504. {      if 'must_be_old'=true  !!!                                              }
  505. {                                                                              }
  506. {          Then the file, which is found first, will be used.                  }
  507. {                                                                              }
  508. {      if 'must_be_old=false' then the first element only will be used.        }
  509. {                                                                              }
  510. {      ----------------------------------------------------------------------- }
  511. {                                                                              }
  512. {      The procedure 'open' will use only the first element of an              }
  513. {      SCL-array and returns if that required file exists.                     }
  514. {                                                                              }
  515. {      The procedure 'openread' requires an existing file and gives            }
  516. {      an error if it does an exist. It will will take a search.               }
  517. {                                                                              }
  518. {      The procedure 'openwrite' uses the first element of an existing         }
  519. {      SCL-reference. There is no error return, if that file does not exit.    }
  520. {                                                                              }
  521. {      The procedure 'openintern' is the internally called routine.            }
  522. {      and is given as an outer interface.                                     }
  523. {                                                                              }
  524. {                                       open  openread   openwrite  openintern }
  525. { ---------------------------------------------------------------------------- }
  526. { var file_variable      : cell          X       X          X          X       }
  527. {     long_name_of_file  : string(64)    X       X          X          X       }
  528. {     textfile           : boolean       X       X          X          X       }
  529. { var effektiv_file_name : string(64)    X       X          X          X       }
  530. {     must_be_old        : boolean     (false) (true)    (false)       X       }
  531. { var is_old_file        : boolean       X       -          -          X       }
  532. { var error              : integer       X       X          X          X       }
  533. {                                                                              }
  534. { parameter-description:                                                       }
  535. {                                                                              }
  536. {     file_variable      : PASCAL file variable  e.g. file of char             }
  537. {     long_name_of_file  : name of the file                                    }
  538. {     textfile           : true if the file is of type 'text'                  }
  539. {                        : That is needed in PASCAL (buffering handling)       }
  540. {     must_be_old        : true, if the file  m u s t  exist.                  }
  541. {                          If 'true' then an hierarchically search will        }
  542. {                          be done                                             }
  543. {     is_old_file        : returns if the file exists                          }
  544. {     error              : <>0 then an error has happened                      }
  545. {                                                                              }
  546. {------------------------------------------------------------------------------}
  547.  
  548. const string_length = 64;
  549. type  string_type   = string(string_length);
  550.  
  551.  
  552. PROCEDURE [XDCL] openread (var file_variable      : cell;
  553.                            long_name_of_file      : string_type;
  554.                            textfile               : boolean;
  555.                            var effektiv_file_name : string_type;
  556.                            var error              : integer);
  557. var is_old_file : boolean;
  558.    openintern (file_variable,long_name_of_file,textfile,
  559.                 effektiv_file_name, true ,is_old_file,  error)
  560. PROCEND;
  561.  
  562.  
  563. PROCEDURE [XDCL] openwrite(var file_variable      : cell;
  564.                            long_name_of_file      : string_type;
  565.                            textfile               : boolean;
  566.                            var effektiv_file_name : string_type;
  567.                            var error              : integer);
  568. var is_old_file : boolean;
  569.    openintern (file_variable,long_name_of_file,textfile,
  570.                 effektiv_file_name, false , is_old_file, error)
  571. PROCEND ;
  572.  
  573.  
  574. PROCEDURE [XDCL] open     (var file_variable      : cell;
  575.                            long_name_of_file      : string_type;
  576.                            textfile               : boolean;
  577.                            var effektiv_file_name : string_type;
  578.                            var is_old_file        : boolean;
  579.                            var error              : integer);
  580.    openintern (file_variable,long_name_of_file,textfile,
  581.                 effektiv_file_name, false , is_old_file, error)
  582. PROCEND ;
  583.  
  584.  
  585. procedure [XDCL] openintern  (var file_variable      : cell;
  586.                               long_name_of_file      : string_type;
  587.                               textfile               : boolean;
  588.                               var effektiv_file_name : string_type;
  589.                               must_be_old            : boolean;
  590.                               var is_old_file        : boolean;
  591.                               var error              : integer);
  592.  
  593.   var i : integer;
  594.  
  595.  
  596.  
  597. { pdt file_pdt ( f : file = $required )
  598.  
  599. ?? PUSH (LISTEXT := ON) ??
  600.  
  601.   VAR
  602.     file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table
  603.       := [^file_pdt_names, ^file_pdt_params];
  604.  
  605.   VAR
  606.     file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
  607.       array [1 .. 1] of clt$parameter_name_descriptor := [['F', 1]];
  608.  
  609.   VAR
  610.     file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1]
  611.       of clt$parameter_descriptor := [
  612.  
  613. { F }
  614.     [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  615.       clc$file_value]]];
  616.  
  617. ?? POP ??
  618.  
  619.  
  620. VAR  k             : integer;
  621. VAR  old_file      : boolean;
  622. VAR  status        :  ost$status;
  623. var  status1,status2,status3,status4 : ost$status;
  624. VAR  parameter_pt  : ^clt$parameter_list;
  625. VAR  value         :  clt$value;
  626. VAR  string_pt     : ^ost$string;
  627. var  param1        : [STATIC]  string(1) := 'F';
  628. var  laenge        : integer;
  629. var  file_reference  : clt$file_reference;
  630. var  path_container : clt$path_container;
  631. var  path           : ^pft$path;
  632. var  cycle_selector : clt$cycle_selector;
  633. var  open_position  : clt$open_position;
  634. var  local_file     : clt$file;
  635. var  file_length    : integer;
  636. var  position       : integer;
  637. var  expanded_name_of_file: string_type;
  638. var  more           : boolean;
  639.  
  640.      error :=0;
  641.  
  642.      PUSH parameter_pt : [[ost$string]];
  643.      RESET parameter_pt;
  644.      NEXT string_pt IN parameter_pt;
  645.  
  646.      position := 1;
  647.  
  648.      /expand/
  649.      WHILE TRUE DO
  650.       expand_file_name(long_name_of_file, position,
  651.                expanded_name_of_file,more);
  652.  
  653.         IF NOT more THEN
  654.            error := -1;
  655.            is_old_file := false;
  656.            RETURN;
  657.         IFEND;
  658.  
  659.         position := position + 1;  { prepare for next cycle }
  660.  
  661.         string_pt^.value := expanded_name_of_file;
  662.         string_pt^.size := string_length;
  663.  
  664.         CLP$PUSH_PARAMETERS (status1);
  665.  
  666.         CLP$SCAN_PARAMETER_LIST(parameter_pt^,file_pdt,status2);
  667.  
  668.         if not status2.normal then
  669.            error := status2.condition;
  670.            PMP$ABORT(status2);
  671.         ifend;
  672.  
  673.         CLP$GET_VALUE(param1,1,1,clc$LOW,value,status3);
  674.  
  675.         CLP$POP_PARAMETERS (status4);
  676.  
  677.         if not status3.normal then
  678.            error := status3.condition;
  679.            PMP$ABORT(status3);
  680.         ifend;
  681.  
  682.         CLP$GET_PATH_DESCRIPTION(value.file,
  683.                                  file_reference,
  684.                                  path_container,
  685.                                  path,
  686.                                  cycle_selector,
  687.                                  open_position,
  688.                                  status3);
  689.  
  690.         if status3.normal then
  691.            effektiv_file_name :=
  692.                   file_reference.path_name(1,file_reference.path_name_size);
  693.         else
  694.            error := status3.condition;
  695.            cycle /expand/;
  696.         ifend;
  697.  
  698.         get_file_length (value.file.local_file_name,file_length,old_file);
  699.  
  700.         IF old_file or NOT must_be_old THEN
  701.            insert_file_variable (file_variable,value.file.local_file_name,
  702.                                  textfile);
  703.            is_old_file := old_file ;
  704.            RETURN;
  705.         IFEND;
  706.  
  707.      WHILEND;
  708.  
  709. procend;
  710.  
  711. procedure [XDCL] buildfname  (var file_variable      : cell;
  712.                               long_name_of_file      : string_type;
  713.                               textfile               : boolean;
  714.                               var effektiv_file_name : string_type;
  715.                               must_be_old            : boolean;
  716.                               var is_old_file        : boolean;
  717.                               var error              : integer);
  718.  
  719.   var i : integer;
  720.  
  721.  
  722.  
  723. { pdt file_pdt ( f : file = $required )
  724.  
  725. ?? PUSH (LISTEXT := ON) ??
  726.  
  727.   VAR
  728.     file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table
  729.       := [^file_pdt_names, ^file_pdt_params];
  730.  
  731.   VAR
  732.     file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
  733.       array [1 .. 1] of clt$parameter_name_descriptor := [['F', 1]];
  734.  
  735.   VAR
  736.     file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1]
  737.       of clt$parameter_descriptor := [
  738.  
  739. { F }
  740.     [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  741.       clc$file_value]]];
  742.  
  743. ?? POP ??
  744.  
  745.  
  746. VAR  k             : integer;
  747. VAR  old_file      : boolean;
  748. VAR  status        :  ost$status;
  749. var  status1,status2,status3,status4 : ost$status;
  750. VAR  parameter_pt  : ^clt$parameter_list;
  751. VAR  value         :  clt$value;
  752. VAR  string_pt     : ^ost$string;
  753. var  param1        : [STATIC]  string(1) := 'F';
  754. var  laenge        : integer;
  755. var  file_reference  : clt$file_reference;
  756. var  path_container : clt$path_container;
  757. var  path           : ^pft$path;
  758. var  cycle_selector : clt$cycle_selector;
  759. var  open_position  : clt$open_position;
  760. var  local_file     : clt$file;
  761. var  file_length    : integer;
  762. var  position       : integer;
  763. var  expanded_name_of_file: string_type;
  764. var  more           : boolean;
  765.  
  766.      error :=0;
  767.  
  768.      PUSH parameter_pt : [[ost$string]];
  769.      RESET parameter_pt;
  770.      NEXT string_pt IN parameter_pt;
  771.  
  772.      position := 1;
  773.  
  774.      /expand/
  775.      WHILE TRUE DO
  776.       expand_file_name(long_name_of_file, position,
  777.                expanded_name_of_file,more);
  778.  
  779.         IF NOT more THEN
  780.            error := -1;
  781.            is_old_file := false;
  782.            RETURN;
  783.         IFEND;
  784.  
  785.         position := position + 1;  { prepare for next cycle }
  786.  
  787.         string_pt^.value := expanded_name_of_file;
  788.         string_pt^.size := string_length;
  789.  
  790.         CLP$PUSH_PARAMETERS (status1);
  791.  
  792.         CLP$SCAN_PARAMETER_LIST(parameter_pt^,file_pdt,status2);
  793.  
  794.         if not status2.normal then
  795.            error := status2.condition;
  796.            PMP$ABORT(status2);
  797.         ifend;
  798.  
  799.         CLP$GET_VALUE(param1,1,1,clc$LOW,value,status3);
  800.  
  801.         CLP$POP_PARAMETERS (status4);
  802.  
  803.         if not status3.normal then
  804.            error := status3.condition;
  805.            PMP$ABORT(status3);
  806.         ifend;
  807.  
  808.         CLP$GET_PATH_DESCRIPTION(value.file,
  809.                                  file_reference,
  810.                                  path_container,
  811.                                  path,
  812.                                  cycle_selector,
  813.                                  open_position,
  814.                                  status3);
  815.  
  816.         if status3.normal then
  817.            effektiv_file_name :=
  818.                   file_reference.path_name(1,file_reference.path_name_size);
  819.         else
  820.            error := status3.condition;
  821.            cycle /expand/;
  822.         ifend;
  823.  
  824.         get_file_length (value.file.local_file_name,file_length,old_file);
  825.  
  826.         IF old_file or NOT must_be_old THEN
  827.            is_old_file := old_file ;
  828.            RETURN;
  829.         IFEND;
  830.  
  831.      WHILEND;
  832.  
  833. procend;
  834.  
  835. procedure get_file_length (file_name : ost$name;
  836.                                   var length : integer ;
  837.                                   var old_file : boolean);
  838.  
  839. var   attributes : ^amt$get_attributes;
  840. var   local      : boolean;
  841. var   non_empty  : boolean;
  842. var   status     : ost$status;
  843.  
  844.  
  845.  PUSH  attributes : [1..1];
  846.  
  847.  attributes^[1].key := amc$file_length;
  848.  
  849.  amp$get_file_attributes(file_name,attributes^,local,old_file,
  850.                          non_empty,status);
  851.  
  852.   if status.normal then
  853.      length := attributes^[1].file_length;
  854.   else
  855.      length := -1;
  856.   ifend;
  857.  
  858. procend get_file_length;
  859.  
  860.  
  861.  
  862.  
  863.  procedure [XDCL] closeread
  864.  
  865.      ( VAR  file_variable :  cell   );
  866.  
  867. type   byte2       = packed array[1..2] of eightbit_range;
  868. type   byte6       = packed array[1..6] of eightbit_range;
  869. type   byte64      = packed array[1..64] of eightbit_range;
  870.  
  871. type   file_ref    = packed record
  872.                        case boolean of
  873.                        = true  =     file_adress : ^cell,
  874.                        = false =     file_adress_bin : byte6,
  875.                       casend,
  876.                      recend;
  877.  
  878.  type  table_entry = packed record
  879.                      file_pt     : file_ref,
  880.                      new_name    : string(31),
  881.                      old_name    : string(31),
  882.                      file_id     : amt$file_identifier,
  883.                      rest1       : byte2,
  884.                      buffer_ptr  : ^cell,
  885.                      rest3       : byte64,
  886.                      recend;
  887.  
  888.  type   table_type = packed array[1..100] of table_entry;
  889.  
  890.  var     hilf_ptr : ^table_type;
  891.  var      nil_test : ^cell;
  892.  var    i : integer;
  893.  var    k : integer;
  894.  var    file_adress_bin : integer;
  895.  var    status : ost$status;
  896.  
  897.        hilf_ptr := PAV$FILE_TABLE_PTR;
  898.        FOR i:=1 to 100 DO
  899.           IF hilf_ptr^[i].file_pt.file_adress_bin[1]=0 THEN
  900.           ELSE
  901.              IF hilf_ptr^[i].file_pt.file_adress = ^file_variable THEN
  902.                 AMP$CLOSE(hilf_ptr^[i].file_id,status);
  903.                 hilf_ptr^[i].file_id.ordinal := 0;
  904.                 hilf_ptr^[i].file_id.sequence:= 1;
  905.                 hilf_ptr^[i].rest1[1] := 0;
  906.                 hilf_ptr^[i].rest1[2] :=50(16);
  907.                 for k:=1 to 64 do hilf_ptr^[i].rest3[k] :=0; forend;
  908.                 hilf_ptr^[i].buffer_ptr := NIL;
  909.                 hilf_ptr^[i].rest3[16] := 0;
  910.                 hilf_ptr^[i].rest3[17] := 1;
  911.                 hilf_ptr^[i].rest3[23] := 1;
  912.                 EXIT closeread;
  913.              IFEND
  914.           IFEND;
  915.        FOREND;
  916.  
  917. PROCEND closeread;
  918.  
  919.  procedure [XDCL] get_file_id
  920.  
  921.      ( VAR  file_variable :  cell;
  922.        VAR  file_id       : amt$file_identifier );
  923.  
  924. type   byte2       = packed array[1..2] of eightbit_range;
  925. type   byte6       = packed array[1..6] of eightbit_range;
  926. type   byte64      = packed array[1..64] of eightbit_range;
  927.  
  928. type   file_ref    = packed record
  929.                        case boolean of
  930.                        = true  =     file_adress : ^cell,
  931.                        = false =     file_adress_bin : byte6,
  932.                       casend,
  933.                      recend;
  934.  
  935.  type  table_entry = packed record
  936.                      file_pt     : file_ref,
  937.                      new_name    : string(31),
  938.                      old_name    : string(31),
  939.                      file_id     : amt$file_identifier,
  940.                      rest1       : byte2,
  941.                      buffer_ptr  : ^cell,
  942.                      rest3       : byte64,
  943.                      recend;
  944.  
  945.  type   table_type = packed array[1..100] of table_entry;
  946.  
  947.  var     hilf_ptr : ^table_type;
  948.  var      nil_test : ^cell;
  949.  var    i : integer;
  950.  var    k : integer;
  951.  var    file_adress_bin : integer;
  952.  var    status : ost$status;
  953.  
  954.        hilf_ptr := PAV$FILE_TABLE_PTR;
  955.        FOR i:=1 to 100 DO
  956.              IF hilf_ptr^[i].file_pt.file_adress = ^file_variable THEN
  957.                 file_id := hilf_ptr^[i].file_id;
  958.                 EXIT get_file_id;
  959.              IFEND
  960.        FOREND;
  961.  
  962. PROCEND get_file_id;
  963.  
  964. { get the local file name of the file }
  965.  
  966.  procedure [XDCL] get_local_file_name
  967.  
  968.      ( VAR  file_variable :  cell;
  969.        VAR  file_name     : amt$local_file_name );
  970.  
  971. type   byte2       = packed array[1..2] of eightbit_range;
  972. type   byte6       = packed array[1..6] of eightbit_range;
  973. type   byte64      = packed array[1..64] of eightbit_range;
  974.  
  975. type   file_ref    = packed record
  976.                        case boolean of
  977.                        = true  =     file_adress : ^cell,
  978.                        = false =     file_adress_bin : byte6,
  979.                       casend,
  980.                      recend;
  981.  
  982.  type  table_entry = packed record
  983.                      file_pt     : file_ref,
  984.                      new_name    : amt$local_file_name, {string(31)}
  985.                      old_name    : amt$local_file_name, {string(31)}
  986.                      file_id     : amt$file_identifier,
  987.                      rest1       : byte2,
  988.                      buffer_ptr  : ^cell,
  989.                      rest3       : byte64,
  990.                      recend;
  991.  
  992.  type   table_type = packed array[1..100] of table_entry;
  993.  
  994.  var     hilf_ptr : ^table_type;
  995.  var      nil_test : ^cell;
  996.  var    i : integer;
  997.  var    k : integer;
  998.  var    file_adress_bin : integer;
  999.  var    status : ost$status;
  1000.  
  1001.        hilf_ptr := PAV$FILE_TABLE_PTR;
  1002.        FOR i:=1 to 100 DO
  1003.              IF hilf_ptr^[i].file_pt.file_adress = ^file_variable THEN
  1004.                 file_name:= hilf_ptr^[i].new_name;
  1005.                 EXIT get_local_file_name;
  1006.              IFEND
  1007.        FOREND;
  1008.  
  1009. PROCEND get_local_file_name;
  1010.  
  1011.  
  1012. PROCEDURE [XDCL]  put_next (var  file_id : amt$file_identifier;
  1013.                     var  buffer  :  cell;
  1014.                     number_of_bytes : amt$working_storage_length);
  1015.  
  1016. VAR  status  : ost$status;
  1017. VAR  adress  : amt$file_byte_address;
  1018.  
  1019.      AMP$put_next(file_id,^buffer,number_of_bytes,adress,status);
  1020.  
  1021. PROCEND put_next;
  1022.  
  1023. { Ausgabe eines mittleren Satzstueckes }
  1024.  
  1025. PROCEDURE [XDCL]  put_partial  (var  file_id : amt$file_identifier;
  1026.                     var  buffer  :  cell;
  1027.                     number_of_bytes : amt$working_storage_length);
  1028.  
  1029. VAR  status  : ost$status;
  1030. VAR  adress  : amt$file_byte_address;
  1031.  
  1032.      AMP$put_partial(file_id,^buffer,number_of_bytes,adress,
  1033.                      amc$continue,status);
  1034.  
  1035. PROCEND put_partial;
  1036.  
  1037. { Ausgabe des ersten Teilsatzes }
  1038.  
  1039. PROCEDURE [XDCL]  put_f_partial  (var  file_id : amt$file_identifier;
  1040.                     var  buffer  :  cell;
  1041.                     number_of_bytes : amt$working_storage_length);
  1042.  
  1043. VAR  status  : ost$status;
  1044. VAR  adress  : amt$file_byte_address;
  1045.  
  1046.      AMP$put_partial(file_id,^buffer,number_of_bytes,adress,
  1047.                      amc$start   ,status);
  1048.  
  1049. PROCEND put_f_partial;
  1050.  
  1051.  
  1052. { Ausgabe des letzten Teilsatzes }
  1053.  
  1054. PROCEDURE [XDCL]  put_l_partial  (var  file_id : amt$file_identifier;
  1055.                     var  buffer  :  cell;
  1056.                     number_of_bytes : amt$working_storage_length);
  1057.  
  1058. VAR  status  : ost$status;
  1059. VAR  adress  : amt$file_byte_address;
  1060.  
  1061.      AMP$put_partial(file_id,^buffer,number_of_bytes,adress,
  1062.                      amc$terminate ,status);
  1063.  
  1064. PROCEND put_l_partial;
  1065.  
  1066.  
  1067. PROCEDURE expand_file_name (     file_name     : string_type;
  1068.                                  position      : integer;      {immer von 1}
  1069.                              var new_file_name : string_type;
  1070.                              var ok            : boolean);
  1071.  
  1072. var  SCL_string_name : string(string_length);
  1073. var  i,j,k           : integer;
  1074. var  SCL_variable    : clt$variable_reference;
  1075. var  status          : ost$status;
  1076. var  actual_name     : string_type;
  1077. var  curpos          : integer;
  1078. var  begin_of_name   : integer;
  1079. var  test_length     : integer;
  1080. var  test_oldfile    : boolean;
  1081. var  string_position : ost$string;
  1082. var  string_ptr      : ^ ost$string;
  1083.  
  1084. { 1. test of old version without '<' }
  1085.  
  1086.     IF  file_name(1) <> '<' THEN
  1087.        ok := position = 1;
  1088.        new_file_name := file_name;
  1089.        RETURN;
  1090.     IFEND;
  1091.     { get the part between '< ... >' }
  1092.     i:=1;
  1093.     REPEAT
  1094.          i:=i+1;
  1095.     UNTIL ( file_name(i)='>') or (i=string_length);
  1096.  
  1097.     begin_of_name := i+ 1;  { first character of rest name }
  1098.  
  1099.     SCL_string_name := file_name(2,begin_of_name-3);
  1100.  
  1101.     CLP$CONVERT_INTEGER_TO_STRING(position,10,FALSE,string_position,status);
  1102.  
  1103.     SCL_string_name(begin_of_name-2) := '(';
  1104.     SCL_string_name(begin_of_name-1,*) :=
  1105.                     string_position.value(1,string_position.size);
  1106.     SCL_string_name(begin_of_name-1+string_position.size) := ')';
  1107.  
  1108.     CLP$READ_VARIABLE ( SCL_string_name,SCL_variable,status);
  1109.  
  1110.     IF NOT status.normal THEN
  1111.        ok := FALSE;
  1112.        RETURN;
  1113.     IFEND;
  1114.  
  1115.     string_ptr:=^ SCL_variable.value.string_value^[1];
  1116.     actual_name:=string_ptr^.value;
  1117.     curpos := string_ptr^.size+1;
  1118.     actual_name(curpos) := '.';
  1119.     actual_name(curpos+1,*) := file_name(begin_of_name,*);
  1120.     ok := TRUE;
  1121.     new_file_name := actual_name;
  1122.  
  1123. PROCEND expand_file_name;
  1124.  
  1125. {  The opensegmented/opensegment-routines give the pointer           }
  1126. {  to the beginning of the file-information usable as a pascal       }
  1127. {  referenz.                                                         }
  1128. {                                                                    }
  1129. {  You can define  (in PASCAL)                                       }
  1130. {     file_refenz : ^packed array[0..???] of 0..255;                 }
  1131. {                                                                    }
  1132. {  Then you can do input easily by array references.                 }
  1133. {  Hint: A file of record type "VARIABLE" begins with 14 bytes       }
  1134. {  header informations                                               }
  1135. {                                                                    }
  1136. {  (There is one "if file_length=0..." with inhibits Output, but     }
  1137. {   without this, you can do output in the same way.                 }
  1138. {                                                                    }
  1139. { in PASCAL                                                          }
  1140. {                                                                    }
  1141. {  type  byte = 0..255;                                              }
  1142. {        two_word = array[1..2] of integer;                          }
  1143. {        byte_ref = ^byte;                                           }
  1144. {        string_type = packed array[1..64] of char;                  }
  1145. {                                                                    }
  1146. {  procedure opensegmented (long_name_of_file                        }
  1147. {                           var current_adress : byte_ref;           }
  1148. {                           var effektiv_file_name : string_type;    }
  1149. {                           var is_old_file        : boolean;        }
  1150. {                           var file_length        : integer;        }
  1151. {                           var file_identifier    : two_word;       }
  1152. {                           var error              : integer;        }
  1153.  
  1154. procedure [XDCL] opensegmented (long_name_of_file      : string_type;
  1155.                                 var file_variable      : ^cell;
  1156.                                 var effektiv_file_name : string_type;
  1157.                                 var is_old_file        : boolean;
  1158.                                 var file_length        : integer;
  1159.                                 var file_identifier    : amt$file_identifier;
  1160.                                 var error              : integer);
  1161.  
  1162.   var i : integer;
  1163.  
  1164.  
  1165. { pdt file_pdt ( f : file = $required )
  1166.  
  1167. ?? PUSH (LISTEXT := ON) ??
  1168.  
  1169.   VAR
  1170.     file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table
  1171.       := [^file_pdt_names, ^file_pdt_params];
  1172.  
  1173.   VAR
  1174.     file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
  1175.       array [1 .. 1] of clt$parameter_name_descriptor := [['F', 1]];
  1176.  
  1177.   VAR
  1178.     file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1]
  1179.       of clt$parameter_descriptor := [
  1180.  
  1181. { F }
  1182.     [[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
  1183.       clc$file_value]]];
  1184.  
  1185. ?? POP ??
  1186.  
  1187.  
  1188. VAR  k                     : integer;
  1189. VAR  old_file              : boolean;
  1190. VAR  status                :  ost$status;
  1191. var  status1,status2,status3,status4 : ost$status;
  1192. var  segment_pointer       : amt$segment_pointer;
  1193. VAR  parameter_pt          : ^clt$parameter_list;
  1194. VAR  value                 :  clt$value;
  1195. VAR  string_pt             : ^ost$string;
  1196. var  param1                : [STATIC]  string(1) := 'F';
  1197. var  laenge                : integer;
  1198. var  file_reference        : clt$file_reference;
  1199. var  path_container        : clt$path_container;
  1200. var  path                  : ^pft$path;
  1201. var  cycle_selector        : clt$cycle_selector;
  1202. var  open_position         : clt$open_position;
  1203. var  local_file            : clt$file;
  1204. var  position              : integer;
  1205. var  expanded_name_of_file : string_type;
  1206. var  more                  : boolean;
  1207.  
  1208.      error :=0;
  1209.  
  1210.      PUSH parameter_pt : [[ost$string]];
  1211.      RESET parameter_pt;
  1212.      NEXT string_pt IN parameter_pt;
  1213.  
  1214.      position := 1;
  1215.  
  1216.      /expand/
  1217.      WHILE TRUE DO
  1218.       expand_file_name(long_name_of_file, position,
  1219.                expanded_name_of_file,more);
  1220.  
  1221.         IF NOT more THEN
  1222.            error := -1;
  1223.            is_old_file := false;
  1224.            RETURN;
  1225.         IFEND;
  1226.  
  1227.         position := position + 1;  { prepare for next cycle }
  1228.  
  1229.         string_pt^.value := expanded_name_of_file;
  1230.         string_pt^.size := string_length;
  1231.  
  1232.         CLP$PUSH_PARAMETERS (status1);
  1233.  
  1234.         CLP$SCAN_PARAMETER_LIST(parameter_pt^,file_pdt,status2);
  1235.  
  1236.         if not status2.normal then
  1237.            error := status2.condition;
  1238.            PMP$ABORT(status2);
  1239.         ifend;
  1240.  
  1241.         CLP$GET_VALUE(param1,1,1,clc$LOW,value,status3);
  1242.  
  1243.         CLP$POP_PARAMETERS (status4);
  1244.  
  1245.         if not status3.normal then
  1246.            error := status3.condition;
  1247.            PMP$ABORT(status3);
  1248.         ifend;
  1249.  
  1250.         CLP$GET_PATH_DESCRIPTION(value.file,
  1251.                                  file_reference,
  1252.                                  path_container,
  1253.                                  path,
  1254.                                  cycle_selector,
  1255.                                  open_position,
  1256.                                  status3);
  1257.  
  1258.         if status3.normal then
  1259.            effektiv_file_name :=
  1260.                   file_reference.path_name(1,file_reference.path_name_size);
  1261.         else
  1262.            error := status3.condition;
  1263.            cycle /expand/;
  1264.         ifend;
  1265.  
  1266.         get_file_length (value.file.local_file_name,file_length,old_file);
  1267.  
  1268.         if file_length=0 then
  1269.            cycle /expand/;
  1270.         ifend;
  1271.  
  1272.         FSP$OPEN_FILE (value.file.local_file_name,
  1273.                        amc$segment,
  1274.                        NIL,                 { file_attachment }
  1275.                        NIL,                 { default_creation_attributes }
  1276.                        NIL,                 { mandated_creation_attributes }
  1277.                        NIL,                 { attribute_validation }
  1278.                        NIL,                 { attribute_override }
  1279.                        file_identifier,status4);
  1280.  
  1281.         if status4.normal then
  1282.            amp$get_segment_pointer(file_identifier,
  1283.                                    amc$cell_pointer,
  1284.                                    segment_pointer,
  1285.                                    status4);
  1286.            file_variable := segment_pointer.cell_pointer;
  1287.            if status4.normal then
  1288.               RETURN;
  1289.            ifend;
  1290.         ifend;
  1291.      WHILEND;
  1292.      error:=1;
  1293.  
  1294. procend opensegmented;
  1295.  
  1296.  
  1297. { set the file_size of a segmented file : the second parameter must }
  1298. { contain the address of the byte behind the last byte of the file }
  1299.  
  1300. procedure [XDCL] setsegmenteoi (
  1301.                            file_identifier  : two_word_id;
  1302.                        var byte_behind_the_last :  cell);
  1303.  
  1304. var segment_pointer : amt$segment_pointer;
  1305. var file_id         : amt$file_identifier;
  1306. var status : ost$status;
  1307. file_id := file_identifier.id;
  1308. segment_pointer.kind := amc$cell_pointer;
  1309. segment_pointer.cell_pointer := ^byte_behind_the_last;
  1310. AMP$SET_SEGMENT_EOI(file_id,segment_pointer,status);
  1311. if not status.normal then
  1312. PMP$ABORT(status);
  1313. ifend;
  1314. procend setsegmenteoi;
  1315.  
  1316. { close the segmented opened file }
  1317.  
  1318. procedure [XDCL] closesegmented (file_identifier : two_word_id);
  1319. var file_id : amt$file_identifier;
  1320. var status : ost$status;
  1321.     file_id := file_identifier.id;
  1322.     FSP$CLOSE_FILE(file_id,status);
  1323.  
  1324.  
  1325. procend closesegmented;
  1326.  
  1327. { alias definition --- needed as the tangle program shortens the  }
  1328. {                      names to 12 characters                     }
  1329.  
  1330. procedure [XDCL] opensegmente  (long_name_of_file      : string_type;
  1331.                                 var file_variable      : ^cell;
  1332.                                 var effektiv_file_name : string_type;
  1333.                                 var is_old_file        : boolean;
  1334.                                 var file_length        : integer;
  1335.                                 var file_identifier    : amt$file_identifier;
  1336.                                 var error              : integer);
  1337.  
  1338.  opensegmented (long_name_of_file  ,
  1339.                 file_variable      ,
  1340.                 effektiv_file_name ,
  1341.                 is_old_file        ,
  1342.                 file_length        ,
  1343.                 file_identifier    ,
  1344.                 error              )
  1345.  
  1346.  
  1347. procend opensegmente;
  1348.  
  1349. procedure [XDCL] closesegment   (file_identifier : two_word_id);
  1350.     closesegmented(file_identifier);
  1351. procend closesegment;
  1352.  
  1353. { to display any status message for control usage of the job }
  1354.  
  1355. procedure [XDCL] display_status ( text : string_type);
  1356. var status : ost$status;
  1357. *COPYC OFP$DISPLAY_STATUS_MESSAGE
  1358. OFP$DISPLAY_STATUS_MESSAGE(text,status);
  1359. RETURN;
  1360. procend display_status;
  1361.  
  1362. { condition handler for user break two                               }
  1363.  
  1364. { It must be called with the parameter 'flag' and the name of        }
  1365. { a procedure which will be executed with condition handling         }
  1366.  
  1367. { PROCEDURE NONBREAK_RUN (VAR FLAG : INTEGER; PROCEDURE P); EXTERNAL; }
  1368.  
  1369. { Then 'P' will be called. 'FLAG' will receive the value '1', if an  }
  1370. { user break 2 has occurred. 'FLAG' should be global to 'P', then    }
  1371. { 'P' can examince the current value of 'FLAG'                       }
  1372.  
  1373. *copyc pmp$establish_condition_handler
  1374.  
  1375. type two_pointer = packed record
  1376.                    binding : ^cell,
  1377.                    static_link : ^cell,
  1378.                    recend;
  1379.  
  1380. PROCEDURE [XDCL] nonbreak_run   (VAR flag : integer;
  1381.                                 main1 : integer; main2 : integer);
  1382. VAR routine : record
  1383.               case boolean of
  1384.               =true=  proc   : ^procedure,
  1385.               =false= cellar : record
  1386.                                int1 : integer,
  1387.                                int2 : integer,
  1388.                                recend,
  1389.               casend,
  1390.               recend,
  1391.     interactive_break : [STATIC] pmt$condition :=
  1392.                         [ifc$interactive_condition, ifc$terminate_break],
  1393.     interactive_break_descriptor: pmt$established_handler,
  1394.     status: ost$status;
  1395.  
  1396.     PROCEDURE ib_handler
  1397.       (    condition: pmt$condition;
  1398.            condition_descriptor: ^pmt$condition_information;
  1399.            save_area: ^ost$stack_frame_save_area;
  1400.        VAR c_status: ost$status);
  1401.  
  1402.  
  1403.       c_status.normal := TRUE;
  1404.       CASE condition.interactive_condition OF
  1405.       = ifc$pause_break =
  1406.         RETURN;
  1407.       = ifc$terminate_break =
  1408.         if flag>0 then
  1409.            pmp$exit(c_status);
  1410.         ifend;
  1411.         flag := 1;
  1412.         RETURN;
  1413.       = ifc$terminal_connection_broken =
  1414.         RETURN;
  1415.       = ifc$job_reconnect =
  1416.         RETURN;
  1417.  
  1418.       CASEND;
  1419.     PROCEND ib_handler;
  1420.  
  1421.     flag := 0;
  1422.     pmp$establish_condition_handler (interactive_break, ^ib_handler,
  1423.           ^interactive_break_descriptor, status);
  1424.     IF NOT status.normal THEN
  1425.       PMP$ABORT(status);
  1426.     IFEND;
  1427.     routine.cellar.int1 := main1;
  1428.     routine.cellar.int2 := main2;
  1429.  
  1430.     routine.proc^;
  1431.   PROCEND nonbreak_run;
  1432.  
  1433. *copyc RMP$GET_DEVICE_CLASS
  1434.  
  1435. PROCEDURE [XDCL] terminal_device ( VAR pascal_file_id : cell;
  1436.                                    VAR terminal : boolean );
  1437. VAR file_name       : amt$local_file_name,
  1438.     device_class    : rmt$device_class,
  1439.     device_assigned : boolean,
  1440.     status          : ost$status;
  1441.  
  1442. get_local_file_name ( pascal_file_id, file_name);
  1443. RMP$GET_DEVICE_CLASS (file_name,device_assigned,device_class, status);
  1444. terminal :=  status.normal AND
  1445.  device_assigned AND (device_class<> RMC$MASS_STORAGE_DEVICE)
  1446.                  AND (device_class<> RMC$MAGNETIC_TAPE_DEVICE);
  1447. procend terminal_device;
  1448.  
  1449. modend;
  1450. 
  1451.